Change do-define-struct' to use make-struct-type' explicitly.

This is to enable the contracts work that is to come.

collects/lang/private/teach.rkt

@@ -37,6 +37,7 @@
   (require mzlib/etc
 	   mzlib/list
 	   mzlib/math
+	   mzlib/pconvert-prop
            scheme/match
            "set-result.ss"
            (only racket/base define-struct)
@@ -51,6 +52,7 @@
 		      syntax/struct
 		      syntax/context
 		      mzlib/include
+		      scheme/list
                       stepper/private/shared)
 
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -103,6 +105,27 @@
   (define-for-syntax (stepper-ignore-checker stx)
     (stepper-syntax-property stx 'stepper-skipto '(syntax-e cdr syntax-e cdr car)))
 
+  (define-for-syntax (map-with-index proc list)
+    (let loop ([i 0] [list list] [rev-result '()])
+      (if (null? list)
+	  (reverse rev-result)
+	  (loop (+ 1 i)
+		(cdr list)
+		(cons (proc i (car list)) rev-result)))))
+
+  ;; build-struct-names is hard to handle
+  (define-for-syntax (make-struct-names name fields stx)
+    (apply (lambda (struct: constructor predicate . rest)
+	     (let loop ([rest rest]
+			[getters '()]
+			[setters '()])
+	       (if (null? rest)
+		   (values struct: constructor predicate (reverse getters) (reverse setters))
+		   (loop (cddr rest)
+			 (cons (car rest) getters)
+			 (cons (cadr rest) setters)))))
+	   (build-struct-names name fields #f #f stx)))
+
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; syntax implementations
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -732,15 +755,23 @@
 		(if (null? (cdr rest))
 		    "one"
 		    "at least one"))))
-	   (let* ([to-define-names (let ([l (build-struct-names name fields #f (not setters?) stx)])
+	   (let-values ([(struct: constructor-name predicate-name getter-names setter-names)
-				     (if struct-info-is-useful?
+			 (make-struct-names name fields stx)]
+			[(field-count) (length fields)])
+	   (let* ([struct-names (list* struct: constructor-name predicate-name
+				       (if setters?
+					   (append getter-names setter-names)
+					   setter-names))]
+		  [to-define-names (if struct-info-is-useful?
 				       ;; All names:
-					 l
+				       struct-names
 				       ;; Skip `struct:' name:
-					 (cdr l)))]
+				       (cdr struct-names))]
 		  [proc-names (if struct-info-is-useful?
 				  (cdr to-define-names)
 				  to-define-names)])
+	       (write (list 'getters getter-names 'setters setter-names) (current-error-port))
+	       (newline (current-error-port))
 	       (with-syntax ([compile-info (if struct-info-is-useful?
 					       (build-struct-expand-info name fields #f (not setters?) #t null null)
 					       (syntax
@@ -765,10 +796,31 @@
 				    (stepper-syntax-property 
 				     #`(define-values (def-proc-name ...)
 					 (let ()
-                                         (define-struct name_ (field_ ...) 
+
-                                           #:transparent 
+					   (define-values (type-descriptor
-                                           #:mutable
+							   raw-constructor
-                                           #:constructor-name #,(car proc-names))
+							   raw-predicate
+							   raw-generic-access
+							   raw-generic-mutate)
+					     (make-struct-type 'name_
+							       #f
+							       #,field-count 0
+							       #f ; auto-v
+							       (list
+								(cons prop:print-convert-constructor-name
+								      '#,(car proc-names)))
+							       #f)) ; inspector
+					   #,@(map-with-index (lambda (i name)
+								#`(define (#,name r)
+								    (raw-generic-access r #,i)))
+							      getter-names)
+					   #,@(map-with-index (lambda (i name)
+								#`(define (#,name r v)
+								    (raw-generic-mutate r #,i v)))
+							      setter-names)
+					   (define #,predicate-name raw-predicate)
+					   (define #,constructor-name raw-constructor)
+
 					   (values proc-name ...)))
 				     'stepper-define-struct-hint
 				     stx))))])
@@ -783,7 +835,7 @@
 					    stx 
 					    (cons #'name_ to-define-names)
 					    defn
-                                          (and setters? bind-names)))))))]
+					    (and setters? bind-names))))))))]
 	[(_ name_ something . rest)
 	 (teach-syntax-error
 	  'define-struct