;;; -*- Mode:Common-Lisp; Package:SYSTEM; Base:10; Fonts:(CPTFONT CPTFONTB HL12BI HL12); Patch-File:T -*-


(defun print-scheme-object (object i-prindepth stream &optional which-operations)
  (declare (ignore which-operations))
  (typecase object
    (fixnum (print-fixnum object stream))
    (null (write-string "()" stream))
    (t (let ((*prindepth* i-prindepth))
	 (clos:print-object object stream)))))

(proclaim '(inline printing-scheme-p))
(defun printing-scheme-p ()
  (eq character-attribute-table
      (character-attribute-table scheme-readtable)))

(defmethod clos:print-object ((object null) stream)
  (if (printing-scheme-p)
      (write-string "()" stream)
    (print-pname-string object stream t)
    object))
    

(defmethod clos:print-object ((object symbol) stream)
  (cond ((not (printing-scheme-p))
	 (print-pname-string object stream t))
	((eq object 't)
	 (write-string "#T" stream))
	((eq object the-eof-object)
	 (write-string "#!EOF" stream))
	((eq object the-unassigned-value)
	 (write-string "#!UNASSIGNED"))
	(t (print-pname-string object stream t)))
  object)

(defmethod clos:print-object ((object float) stream)
  (if (printing-scheme-p)
      (let ((type (type-of object)))
	(if (or (eq type *read-default-float-format*)
		(eq type 'short-float))
	    (print-flonum object stream)
	  (let ((*read-default-float-format* type)) ; force print-flonum to use E
	    ;; write the appropriate Scheme prefix
	    (write-char #\# stream)
	    (write-char (if (eq type 'single-float) #\S #\L) stream)
	    (print-flonum object stream))))
    (print-flonum object stream))
  object)