(defmacro redirect-place (setf-expander-macro place &environment env)
  (multiple-value-bind (vars vals stores write read)
      (funcall (macro-function setf-expander-macro env) place env)
    (declare (ignore stores write))
    `(let* ,(mapcar #'list vars vals)
       ,read)))

(define-setf-expander redirect-place (setf-expander-macro place
                                      &environment env)
  (funcall (macro-function setf-expander-macro env) place env))

(defmacro with-setf-expander ((access-fn lambda-list &body expander-body)
                              &body with-body)
  (let ((expander (gensym))
        (ignore (gensym))
        (place (gensym)))
    `(macrolet ((,expander ,lambda-list
                  ;; PORTABILITY: This assumes MACROLET can define a macro
                  ;; function that returns multiple values.  If your Lisp
                  ;; implementation disagrees, you can wrap the values in
                  ;; a list instead.  But then you'd have to separate the
                  ;; body into declarations and forms.
                  ,@expander-body)
                (,access-fn (&whole ,place &rest ,ignore)
                  (declare (ignore ,ignore))
                  `(redirect-place ,',expander ,,place)))
       ,@with-body)))

;; test
(let ((x 42))
  (with-setf-expander (1plus (place &environment env)
                        (multiple-value-bind (vars vals stores write read)
                            (get-setf-expansion place env)
                          (let ((store (gensym)))
                            (values vars vals `(,store)
                                    `(multiple-value-bind (,@stores)
                                         (1- ,store)
                                       ,write)
                                    `(1+ ,read)))))
    (values (1plus x)                   ; 43
            (shiftf (1plus x) 69)       ; 43
            (1plus x)                   ; 69
            x)))                        ; 68