Non-system procedures now print with source-position. E.g.,

you now get #<procedure foo [nnn of file.ss]> or
#<procedure [nnn of file.ss]>  instead of plain #<procedure foo>
or #<procedure>.

scheme/ikarus.compiler.ss

@@ -256,15 +256,19 @@
         [(null? fmls) (null? args)]
         [(pair? fmls) (and (pair? args) (matching? (cdr fmls) (cdr args)))]
         [else #t]))
-    (cond
+    (define (get-cls* x)
-      [(and (pair? x) (eq? (car x) 'case-lambda))
+      (if (pair? x)
-       (let f ([cls* (cdr x)])
+          (case (car x)
-         (cond
+            [(case-lambda) (cdr x)]
-           [(null? cls*) '()]
+            [(annotated-case-lambda) (cddr x)]
-           [(matching? (caar cls*) args) 
+            [else '()])
-            (caar cls*)]
+          '()))
-           [else (f (cdr cls*))]))]
+    (let f ([cls* (get-cls* x)])
-      [else '()]))
+      (cond
+        [(null? cls*) '()]
+        [(matching? (caar cls*) args)
+         (caar cls*)]
+        [else (f (cdr cls*))])))
   (define (make-global-set! lhs rhs)
     (make-funcall (make-primref '$init-symbol-value!)
       (list (make-constant lhs) rhs)))
@@ -283,6 +287,22 @@
                                       (begin e e* ...)
                                       rest))]))])
             #'(let ([t val]) body))])))
+
+  (define (E-clambda-clause* cls* ctxt)
+    (map
+      (let ([ctxt (if (pair? ctxt) (car ctxt) #f)])
+        (lambda (cls)
+          (let ([fml* (car cls)] [body (cadr cls)])
+            (let ([nfml* (gen-fml* fml*)])
+              (let ([body (E body ctxt)])
+                (ungen-fml* fml*)
+                (make-clambda-case 
+                  (make-case-info
+                    (gensym)
+                    (properize nfml*) 
+                    (list? fml*)) 
+                  body))))))
+           cls*))
   (define (E x ctxt)
     (cond
       [(pair? x)
@@ -342,23 +362,18 @@
                   (ungen-fml* lhs*)
                   expr))))]
          [(case-lambda)
-          (let ([cls*
+          (let ([cls* (E-clambda-clause* (cdr x) ctxt)])
-                 (map
-                   (let ([ctxt (if (pair? ctxt) (car ctxt) #f)])
-                     (lambda (cls)
-                       (let ([fml* (car cls)] [body (cadr cls)])
-                         (let ([nfml* (gen-fml* fml*)])
-                           (let ([body (E body ctxt)])
-                             (ungen-fml* fml*)
-                             (make-clambda-case 
-                               (make-case-info
-                                 (gensym)
-                                 (properize nfml*) 
-                                 (list? fml*)) 
-                               body))))))
-                   (cdr x))])
             (make-clambda (gensym) cls* #f #f
               (and (symbol? ctxt) ctxt)))]
+         [(annotated-case-lambda)
+          (let ([ae (cadr x)])
+            (let ([cls* (E-clambda-clause* (cddr x) ctxt)])
+              (make-clambda (gensym) cls* #f #f
+                (cons 
+                  (and (symbol? ctxt) ctxt)
+                  (if (annotation? ae)
+                      (annotation-source ae)
+                      #f)))))]
          [(lambda) 
           (E `(case-lambda ,(cdr x)) ctxt)]
          [(foreign-call)

scheme/ikarus.writer.ss

@@ -556,14 +556,25 @@
         (write-char (string-ref x i) p)
         (f x p (fx+ i 1) n))))
   (define (write-procedure x p)
-    (cond
+    (write-char* "#<procedure" p)
-      [(let ([name (procedure-annotation x)])
+    (let-values ([(name src) 
-         (and (symbol? name) name)) =>
+                  (let ([ae (procedure-annotation x)])
-       (lambda (name) 
+                    (if (pair? ae)
-         (write-char* "#<procedure " p)
+                        (values (car ae) (cdr ae))
-         (write-string (symbol->string name) p #f)
+                        (if (symbol? ae)
-         (write-char* ">" p))]
+                            (values ae #f)
-      [else (write-char* "#<procedure>" p)]))
+                            (values #f #f))))])
+      (when (symbol? name)
+        (write-char* " " p)
+        (display name p))
+      (when (pair? src)
+        (let ([file (car src)] [char (cdr src)])
+          (write-char* " [char " p)
+          (display char p)
+          (write-char* " of " p)
+          (display file p)
+          (write-char* "]" p))))
+    (write-char* ">" p))
   (define (write-port x p)
     (write-char* "#<" p)
     (write-char* (if (output-port? x) "output" "input") p)

scheme/psyntax.builders.ss

@@ -57,12 +57,14 @@
   (define build-lambda
     (lambda (ae vars exp) 
       (if-wants-case-lambda
-          `(case-lambda (,vars ,exp))
+        (build-case-lambda ae (list vars) (list exp))
-          `(lambda ,vars ,exp))))
+        `(lambda ,vars ,exp))))
   (define build-case-lambda
     (if-wants-case-lambda
       (lambda (ae vars* exp*)
-        `(case-lambda . ,(map list vars* exp*)))
+        (if ae
+            `(annotated-case-lambda ,ae . ,(map list vars* exp*))
+            `(case-lambda . ,(map list vars* exp*))))
       (lambda (ae vars* exp*)
         (define (build-error ae)
           (build-application ae 

scheme/psyntax.expander.ss

@@ -873,7 +873,7 @@
         ((_ (id . fmls) b b* ...) (id? id)
          (begin
            (verify-formals fmls x)
-           (values id (cons 'defun (cons fmls (cons b b*))))))
+           (values id (cons 'defun x))))
         ((_ id val) (id? id)
          (values id (cons 'expr val)))
         ((_ id) (id? id)
@@ -1061,7 +1061,7 @@
          (let-values (((fmls* body*)
                        (chi-lambda-clause* e fmls*
                          (map cons b* b**) r mr)))
-           (build-case-lambda no-source fmls* body*))))))
+           (build-case-lambda (syntax-annotation e) fmls* body*))))))
   
   (define lambda-transformer
     (lambda (e r mr)
@@ -1070,7 +1070,7 @@
          (let-values (((fmls body)
                        (chi-lambda-clause e fmls
                           (cons b b*) r mr)))
-           (build-lambda no-source fmls body))))))
+           (build-lambda (syntax-annotation e) fmls body))))))
   
   (define bless
     (lambda (x)
@@ -2874,10 +2874,11 @@
              (values (cons a a*) (cons b b*))))))))
 
   (define (chi-defun x r mr)
-    (let ((fmls (car x)) (body* (cdr x)))
+    (syntax-match x ()
-      (let-values (((fmls body)
+      [(_ (_ . fmls) . body*)
-                    (chi-lambda-clause fmls fmls body* r mr)))
+       (let-values (((fmls body)
-        (build-lambda no-source fmls body))))
+                     (chi-lambda-clause fmls fmls body* r mr)))
+         (build-lambda (syntax-annotation x) fmls body))]))
 
   (define chi-rhs
     (lambda (rhs r mr)
@@ -3918,6 +3919,9 @@
            (and (annotation? x)
                 (annotation-source x)))))
 
+  (define (syntax-annotation x)
+    (if (stx? x) (stx-expr x) x))
+
   (define (assertion-error expr pos)
     (raise
       (condition