- (write-string "#<" stream)
- (when type
- (write (type-of object) :stream stream :circle nil
- :level nil :length nil)
- (write-char #\space stream))
- (when body
- (funcall body))
- (when identity
- (unless (and type (null body))
- (write-char #\space stream))
- (write-char #\{ stream)
- (write (get-lisp-obj-address object) :stream stream
- :radix nil :base 16)
- (write-char #\} stream))
- (write-char #\> stream)
+ (flet ((print-description ()
+ (when type
+ (write (type-of object) :stream stream :circle nil
+ :level nil :length nil)
+ (when (or body identity)
+ (write-char #\space stream)
+ (pprint-newline :fill stream)))
+ (when body
+ (funcall body))
+ (when identity
+ (when body
+ (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))))