(defun store-value-read-evaluated-form ()
  (format *query-io* "~&;; Type a form to be evaluated:~%")
  (list (eval (read *query-io*))))

(defmacro with-store-value-restart ((temp-var place tag) &body forms)
  (let ((report-var (gensym "STORE-VALUE-REPORT"))
        (new-value-var (gensym "NEW-VALUE"))
        (form-or-forms (if (= 1 (length forms)) (first forms) `(progn ,@forms))))
    `(flet ((,report-var (stream)
              (format stream "Supply a new value of ~S." ',place)))
       (restart-case ,form-or-forms
         (store-value (,new-value-var)
           :report ,report-var
           :interactive store-value-read-evaluated-form
           (setf ,temp-var ,new-value-var
                 ,place ,new-value-var)
           (go ,tag))))))

(defun check-type-error (place value type type-string)
  (error
   'simple-type-error
   :datum value
   :expected-type type
   :format-control (if type-string
                       "The value of ~S is ~S, which is not ~A."
                       "The value of ~S is ~S, which is not of type ~S.")
   :format-arguments (list place value (or type-string type))))

(defmacro check-type* (place type &optional type-string)
  "Like CHECK-TYPE, except TYPE is evaluated on each assertion."
  (let ((variable (gensym "CHECK-TYPE-VARIABLE"))
        (tag (gensym "CHECK-TYPE-TAG"))
        (type-gensym (gensym "CHECK-TYPE-TYPE")))
    `(let ((,variable ,place))
       (tagbody ,tag
          (let ((,type-gensym ,type))
            (unless (typep ,variable ,type-gensym)
              (with-store-value-restart (,variable ,place ,tag)
                (check-type-error ',place ,variable ,type-gensym
                                  ,type-string))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

CL-USER> (let ((x 2)) (check-type* x 'integer))
NIL

CL-USER> (handler-case (let ((x 2)) (check-type* x 'string))
           (error (e) (princ-to-string e)))
"The value of X is 2, which is not of type STRING."