- (when *print-readably*
- (restart-case
- (error 'print-not-readable :object object)
- (print-unreadably ()
- :report "Print unreadably.")
- (use-value (o)
- :report "Supply an object to be printed instead."
- :interactive read-unreadable-replacement
- (write o :stream stream)
- (return-from %print-unreadable-object nil))))
- (flet ((print-description ()
- (when type
- (write (type-of object) :stream stream :circle nil
- :level nil :length nil)
- (write-char #\space stream)
- (pprint-newline :fill stream))
- (when body
- (funcall body))
- (when identity
- (when (or body (not type))
- (write-char #\space stream))
- (pprint-newline :fill stream)
- (write-char #\{ stream)
- (write (get-lisp-obj-address object) :stream stream
- :radix nil :base 16)
- (write-char #\} stream))))
- (cond ((print-pretty-on-stream-p stream)
- ;; Since we're printing prettily on STREAM, format the
- ;; object within a logical block. PPRINT-LOGICAL-BLOCK does
- ;; not rebind the stream when it is already a pretty stream,
- ;; so output from the body will go to the same stream.
- (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
- (print-description)))
- (t
- (write-string "#<" stream)
- (print-description)
- (write-char #\> stream))))
+ (if *print-readably*
+ (print-not-readable-error object stream)
+ (flet ((print-description ()
+ (when type
+ (write (type-of object) :stream stream :circle nil
+ :level nil :length nil)
+ (write-char #\space stream)
+ (pprint-newline :fill stream))
+ (when body
+ (funcall body))
+ (when identity
+ (when (or body (not type))
+ (write-char #\space stream))
+ (pprint-newline :fill stream)
+ (write-char #\{ stream)
+ (write (get-lisp-obj-address object) :stream stream
+ :radix nil :base 16)
+ (write-char #\} stream))))
+ (cond ((print-pretty-on-stream-p stream)
+ ;; Since we're printing prettily on STREAM, format the
+ ;; object within a logical block. PPRINT-LOGICAL-BLOCK does
+ ;; not rebind the stream when it is already a pretty stream,
+ ;; so output from the body will go to the same stream.
+ (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
+ (print-description)))
+ (t
+ (write-string "#<" stream)
+ (print-description)
+ (write-char #\> stream)))))