define-struct for the whalesong language uses mutable, transparent structures by default

lang/whalesong.rkt

@@ -6,6 +6,8 @@
 ;;     * Automatically running tests
 ;;     * Annotating all applications so they produce stack traces on error
 ;;     * Adding the "shared" form by default.
+;;     * define-struct automatically has #:transparent and #:mutable
+
 
 (require "base.rkt"
          "private/traced-app.rkt"
@@ -19,9 +21,11 @@
 
 (provide (except-out (all-from-out "base.rkt")
                      #%app
-                     #%module-begin)
+                     #%module-begin
+                     define-struct)
          (rename-out [traced-app #%app]
-                     [my-module-begin #%module-begin])
+                     [my-module-begin #%module-begin]
+                     [my-define-struct define-struct])
          shared
          (all-from-out "bool.rkt")
          (except-out (all-from-out "check-expect/check-expect.rkt")
@@ -34,4 +38,23 @@
     [(_ body ...)
      (syntax/loc stx
        (#%module-begin body ...
-                       (run-tests)))]))
+                       (run-tests)))]))
+
+
+
+(define-syntax (my-define-struct stx)
+  (syntax-case stx ()
+    [(_ id (fields ...) options ...)
+     (let* ([new-options (syntax->list #'(options ...))]
+            [new-options (cond [(memq '#:transparent (map syntax-e new-options))
+                                new-options]
+                           [else
+                            (cons (syntax #:transparent) new-options)])]
+            [new-options (cond [(memq '#:mutable (map syntax-e new-options))
+                                new-options]
+                               [else
+                                (cons (syntax #:mutable) new-options)])])
+       (with-syntax [((new-options ...) new-options)]
+         (syntax/loc stx
+           (define-struct id (fields ...) new-options ...))))]))
+