.

original commit: c803e704a30e17c2562deaeaba05e938e9acb92e

collects/mzlib/class.ss

@@ -1263,27 +1263,34 @@
   ;;  object%
   ;;--------------------------------------------------------------------
   
-  (define object<%> (make-interface 'object% null null #f))
-  (define object% (make-class 'object%
-			      0 (vector #f) 
-			      object<%>
+  (define (make-naming-constructor type name)
+    (let-values ([(struct: make- ? -accessor -mutator)
+		  (make-struct-type name type 0 0 #f null insp)])
+      make-))
+  
+  (define object<%> ((make-naming-constructor struct:interface 'interface:object%)
+		     'object% null null #f))
+  (define object% ((make-naming-constructor struct:class 'class:object%)
+		   'object%
+		   0 (vector #f) 
+		   object<%>
 
-			      0 (make-hash-table) null
-			      (vector) (vector)
-			      
-			      0 (make-hash-table) null
-			      
-			      'struct:object object? 'make-object
-			      'field-ref-not-needed 'field-set!-not-needed
+		   0 (make-hash-table) null
+		   (vector) (vector)
+		   
+		   0 (make-hash-table) null
+		   
+		   'struct:object object? 'make-object
+		   'field-ref-not-needed 'field-set!-not-needed
 
-			      null
+		   null
 
-			      (lambda (this super-init args) 
-				(unless (null? args)
-				  (obj-error "make-object" "unused initialization arguments: ~e" args))
-				(void))
+		   (lambda (this super-init args) 
+		     (unless (null? args)
+		       (obj-error "make-object" "unused initialization arguments: ~e" args))
+		     (void))
 
-			      #t)) ; no super-init
+		   #t)) ; no super-init
 
   (vector-set! (class-supers object%) 0 object%)
   (let*-values ([(struct:obj make-obj obj? -get -set!)
@@ -1644,11 +1651,6 @@
   
   (define undefined (letrec ([x x]) x))
   
-  (define (make-naming-constructor type name)
-    (let-values ([(struct: make- ? -accessor -mutator)
-		  (make-struct-type name type 0 0 #f null insp)])
-      make-))
-
   (define-struct (exn:object struct:exn) () insp)
 
   (define (obj-error where . msg)

collects/mzlib/cmdline.ss

@@ -177,7 +177,7 @@
   
   (define print-args
     (lambda (port l f)
-      (let loop ([l l][a (letrec ([a (arity f)]
+      (let loop ([l l][a (letrec ([a (procedure-arity f)]
 				  [a-c (lambda (a)
 					 (cond
 					  [(number? a) (cons (sub1 a) (sub1 a))]
@@ -204,7 +204,7 @@
 		 [(number? a) (>= a n)]
 		 [(arity-at-least? a) #t]
 		 [else (ormap a-c a)]))])
-      (a-c (arity p))))
+      (a-c (procedure-arity p))))
 
   (define parse-command-line
     (case-lambda
@@ -267,7 +267,7 @@
 					 (or (procedure? (cadr line))
 					     (bad-table (format "second item in a spec-line must be a procedure: ~e" (cadr line))))
 
-					 (let ([a (arity (cadr line))])
+					 (let ([a (procedure-arity (cadr line))])
 					   (or (and (number? a)
 						    (or (>= a 1)
 							(bad-table (format "flag handler procedure must take at least 1 argument: ~e" 
@@ -280,7 +280,7 @@
 					     (bad-table (format "spec-line help section must be a list of strings")))
 					 
 					 (or (let ([l (length (caddr line))]
-						   [a (arity (cadr line))])
+						   [a (procedure-arity (cadr line))])
 					       (if (number? a)
 						   (= a l)
 						   (and (>= l 1)
@@ -297,11 +297,11 @@
       (unless (and (procedure? help) (procedure-arity-includes? help 1))
 	(raise-type-error 'parse-command-line "help procedure of arity 1" help))
       (unless (and (procedure? unknown-flag) (procedure-arity-includes? unknown-flag 1)
-		   (let ([a (arity unknown-flag)])
+		   (let ([a (procedure-arity unknown-flag)])
 		     (or (number? a) (arity-at-least? a))))
 	(raise-type-error 'parse-command-line "unknown-flag procedure of simple arity, accepting 1 argument (an perhaps more)" unknown-flag))
       
-      (letrec ([a (arity finish)]
+      (letrec ([a (procedure-arity finish)]
 	       [l (length finish-help)]
 	       [a-c (lambda (a)
 		      (or (and (number? a) (sub1 a))
@@ -404,7 +404,7 @@
 					   (parameterize ([current-output-port s])
 					     (print-args s finish-help finish))
 					   (let ([s (get-output-string s)])
-					     (if (equal? 2 (arity finish))
+					     (if (equal? 2 (procedure-arity finish))
 						 (format " 1~a" s)
 						 s))))
 				     c
@@ -418,7 +418,7 @@
 					   (string-append (car args) " " (loop (cdr args))))))))))]
 	     [call-handler
 	      (lambda (handler flag args r-acc k)
-		(let* ([a (arity handler)]
+		(let* ([a (procedure-arity handler)]
 		       [remaining (length args)]
 		       [needed (if (number? a)
 				   (sub1 a)

collects/mzlib/etc.ss

@@ -3,8 +3,7 @@
   (require "spidey.ss")
   (require-for-syntax (lib "kerncase.ss" "syntax"))
 
-  (provide this-expression-source-directory
-           true false
+  (provide true false
 	   boolean=? symbol=?
 	   identity
 	   compose
@@ -23,20 +22,10 @@
 	   evcase
 	   nor
 	   nand
-	   let+)
+	   let+
+
+	   this-expression-source-directory)
   
-  (define-syntax (this-expression-source-directory stx)
-    (syntax-case stx ()
-      [(_)
-       (let ([source (syntax-source stx)])
-         (if (and source
-                  (string? source)
-                  (file-exists? source))
-             (let-values ([(base file dir?) (split-path source)])
-               (with-syntax ([base base])
-                 (syntax base)))
-             (syntax #f)))]))
-    
   (define true #t)
   (define false #f)
   
@@ -49,11 +38,11 @@
       [(f g)
        (let ([f (compose f)]
              [g (compose g)])
-         (if (eqv? 1 (arity f)) ; optimize: don't use call-w-values
-             (if (eqv? 1 (arity g)) ; optimize: single arity everywhere
+         (if (eqv? 1 (procedure-arity f)) ; optimize: don't use call-w-values
+             (if (eqv? 1 (procedure-arity g)) ; optimize: single arity everywhere
                  (lambda (x) (f (g x)))
                  (lambda args (f (apply g args))))
-             (if (eqv? 1 (arity g)) ; optimize: single input
+             (if (eqv? 1 (procedure-arity g)) ; optimize: single input
                  (lambda (a)
                    (call-with-values
                     (lambda () (g a))
@@ -375,5 +364,17 @@
 		  [(recs (var expr) ...)
 		   (syntax (letrec ([var expr] ...) rest))]
 		  [(_ expr)
-		   (syntax (begin expr rest))])))))]))))
+		   (syntax (begin expr rest))])))))])))
 
+ (define-syntax (this-expression-source-directory stx)
+   (syntax-case stx ()
+     [(_)
+      (let ([source (syntax-source stx)])
+	(if (and source
+		 (string? source)
+		 (file-exists? source))
+	    (let-values ([(base file dir?) (split-path source)])
+	      (with-syntax ([base base])
+		(syntax base)))
+	    (syntax (or (current-load-relative-directory)
+			(current-directory)))))])))

collects/mzlib/thread.ss

@@ -58,10 +58,10 @@
 		     (raise 
 		      (make-exn:application:arity
 		       (format "<procedure-from-consumer-thread>: consumer procedure arity is ~e; provided ~s argument~a"
-			       (arity f) num (if (= 1 num) "" "s"))
+			       (procedure-arity f) num (if (= 1 num) "" "s"))
 		       (current-continuation-marks)
 		       num
-		       (arity f)))))
+		       (procedure-arity f)))))
 	   (semaphore-wait protect)
 	   (set! front-state (cons new-state front-state))
 	   (semaphore-post protect)

collects/mzlib/unit.ss

@@ -8,9 +8,24 @@
 
   (define undefined (letrec ([x x]) x))
 
+  (define insp (current-inspector)) ; for named structures
+
   (define-struct unit (num-imports exports go))
   (define-struct (exn:unit struct:exn) ())
 
+  (define (make-naming-constructor type name)
+    (let-values ([(struct: make- ? -accessor -mutator)
+		  (make-struct-type name type 0 0 #f null insp)])
+      make-))
+
+  (define (make-a-unit name num-imports exports go)
+    ((if name 
+	 (make-naming-constructor 
+	  struct:unit
+	  (string->symbol (format "unit:~a" name)))
+	 make-unit)
+     num-imports exports go))
+
   (define-syntax unit
     (lambda (stx)
       (syntax-case stx (import export)
@@ -241,20 +256,21 @@
 					 [num-imports (datum->syntax-object
 						       (quote-syntax here)
 						       (length (syntax->list (syntax (iloc ...))))
-						       #f)])
-			     (syntax/loc
-			      stx
-			      (make-unit
-			       num-imports
-			       (list (quote extname) ...)
-			       (lambda ()
-				 (let ([eloc (box undefined)] ...)
-				   (list (vector eloc ...)
-					 (lambda (iloc ...)
-					   (let ([intname undefined] ...)
-					     (letrec-syntax redirections
-						 (void) ; in case the body would be empty
-					       defn&expr ...))))))))))))))))))])))
+						       #f)]
+					 [name (syntax-local-name)])
+			     (syntax/loc stx
+			       (make-a-unit
+				'name
+				num-imports
+				(list (quote extname) ...)
+				(lambda ()
+				  (let ([eloc (box undefined)] ...)
+				    (list (vector eloc ...)
+					  (lambda (iloc ...)
+					    (let ([intname undefined] ...)
+					      (letrec-syntax redirections
+						(void) ; in case the body would be empty
+						defn&expr ...))))))))))))))))))])))
   
   (define (check-expected-interface tag unit num-imports exports)
     (unless (unit? unit)
@@ -560,7 +576,8 @@
 						   (length imports)
 						   #f)]
 				     [export-names export-names]
-				     [export-mapping export-mapping])
+				     [export-mapping export-mapping]
+				     [name (syntax-local-name)])
 			 (syntax/loc
 			  stx
 			  (let ([constituent unit-expr]
@@ -572,7 +589,8 @@
 				    unit-import-count
 				    'unit-export-list)]
 				  ...)
-			      (make-unit
+			      (make-a-unit
+			       'name
 			       num-imports
 			       (quote export-names)
 			       (lambda ()